home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 011-020 / amok13 / wbshadow / wbshadow.mod < prev    next >
Text File  |  1993-11-04  |  6KB  |  205 lines
  1. (*---------------------------------------------------------------------------
  2.   :Program.    WBShadow.mod
  3.   :Author.     Fridtjof Siebert
  4.   :Address.    Nobileweg 67, D-7-Stgt-40
  5.   :Phone.      (0)711/822509
  6.   :Shortcut.   [fbs]
  7.   :Version.    1.0
  8.   :Date.       26-Jan-89
  9.   :Copyright.  PD
  10.   :Language.   Modula-II
  11.   :Translator. M2Amiga v3.1d
  12.   :Imports.    arp.library
  13.   :Contents.   Program to create shadows of the things on your Workbench
  14.   :Remark.     It's terrible! Everything I program is senseless!!
  15. ---------------------------------------------------------------------------*)
  16.  
  17. MODULE WBShadow;
  18.  
  19. FROM SYSTEM      IMPORT ADR, ADDRESS, LONGSET, CAST, BITSET;
  20. FROM Arts        IMPORT Assert, TermProcedure, Terminate;
  21. FROM Dos         IMPORT Delay;
  22. FROM Exec        IMPORT Forbid, Permit, FindPort, MsgPortPtr, NodeType,
  23.                         Message, MessagePtr, GetMsg, ReplyMsg, PutMsg,
  24.                         WaitPort;
  25. FROM ExecSupport IMPORT CreatePort, DeletePort;
  26. FROM Intuition   IMPORT ScreenPtr, MakeScreen, RethinkDisplay, NewWindow,
  27.                         WindowFlags, WindowFlagSet, ScreenFlags, CloseWindow,
  28.                         ScreenFlagSet, IDCMPFlagSet, OpenWindow, WindowPtr;
  29. FROM Graphics    IMPORT BitMap, BltBitMap;
  30. FROM Heap        IMPORT AllocMem;
  31.  
  32. (*------  CONSTS:  ------*)
  33.  
  34. CONST
  35.   WindowTitle = "WBShadow © Fridtjof Siebert / AMOK Stuttgart";
  36.   PortName    = "NewWBPlanes[fbs].Port";
  37.   ReplyName   = "NewWBPlanes[fbs].ReplyPort";
  38.  
  39. (*------  TYPES:  ------*)
  40.  
  41. TYPE
  42.   ColorMap = ARRAY[0..31] OF INTEGER;
  43.  
  44. (*------  VARS:  ------*)
  45.  
  46. VAR
  47.   WBScreen: ScreenPtr;
  48.   NewPlane1, NewPlane2, OldPlane1, OldPlane2: ADDRESS;
  49.   OldbPR, OldRows: CARDINAL;
  50.   ColTable: POINTER TO ColorMap;
  51.   Window: WindowPtr;
  52.   NuWindow: NewWindow;
  53.   MyMsg: Message;
  54.   QuitMessage: MessagePtr;
  55.   MyPort, OldPort: MsgPortPtr;
  56.   l: LONGINT;
  57.   bm: BitMap;
  58.  
  59. (*------  CleanUp:  ------*)
  60.  
  61. PROCEDURE CleanUp();
  62.  
  63. BEGIN
  64.  
  65. (*------  Remove Picture from WB:  ------*)
  66.  
  67.   IF WBScreen#NIL THEN
  68.     Forbid();
  69.       WITH WBScreen^ DO
  70.         WITH bitMap DO
  71.           depth := 2;
  72.           planes[2] := NIL;
  73.           IF OldPlane1#NIL THEN planes[0] := OldPlane1;
  74.             IF OldPlane2#NIL THEN planes[1] := OldPlane2;
  75.               IF OldRows#0 THEN rows := OldRows;
  76.                 IF OldbPR#0 THEN bytesPerRow := OldbPR;
  77.                   l := BltBitMap(ADR(bm),16,8,ADR(bitMap),0,0,
  78.                                  width,height,0C0H,3,NIL);
  79.                 END;
  80.               END;
  81.             END;
  82.           END;
  83.         END;
  84.       END;
  85.       MakeScreen(WBScreen);
  86.     Permit();
  87.     RethinkDisplay();
  88.   END;
  89.  
  90. (*------  Close everything:  ------*)
  91.  
  92.   IF Window#NIL THEN CloseWindow(Window); END;
  93.  
  94. (*------  Remove Port:  ------*)
  95.  
  96.   IF MyPort#NIL THEN
  97.     Forbid();
  98.       IF QuitMessage=NIL THEN QuitMessage := GetMsg(MyPort) END;
  99.       WHILE QuitMessage#NIL DO
  100.         ReplyMsg(QuitMessage);
  101.         QuitMessage := GetMsg(MyPort);
  102.       END;
  103.       DeletePort(MyPort);
  104.     Permit();
  105.   END;
  106.  
  107. END CleanUp;
  108.  
  109. (*------  MAIN:  ------*)
  110.  
  111. BEGIN
  112.  
  113. (*------  Initialization:  ------*)
  114.  
  115.   WBScreen := NIL; Window := NIL; MyPort := NIL;
  116.   OldPlane1 := NIL; OldPlane2 := NIL; OldbPR := 0; OldRows := 0;
  117.   TermProcedure(CleanUp);
  118.  
  119. (*------  Have we already been started?  ------*)
  120.  
  121.   OldPort := FindPort(ADR(PortName));
  122.   IF OldPort#NIL THEN
  123.     MyPort := CreatePort(ADR(ReplyName),0);
  124.     Assert(MyPort#NIL,ADR("CreatePort failed"));
  125.     MyMsg.node.type := message;
  126.     MyMsg.replyPort := MyPort;
  127.     PutMsg(OldPort,ADR(MyMsg)); (* Signal task to quit *)
  128.     WaitPort(MyPort);
  129.     DeletePort(MyPort);
  130.     MyPort := NIL;
  131.     Terminate(0);
  132.   END;
  133.   MyPort := CreatePort(ADR(PortName),0);
  134.   Assert(MyPort#NIL,ADR("CreatePort failed"));
  135.  
  136. (*------  Open Window:  ------*)
  137.  
  138.   WITH NuWindow DO
  139.     leftEdge   := 0; topEdge     := 0;
  140.     width      := 1; height      := 1;
  141.     detailPen  := 0; blockPen    := 1;
  142.     idcmpFlags := IDCMPFlagSet{};
  143.     flags      := WindowFlagSet{backDrop};
  144.     firstGadget:= NIL; checkMark := NIL;
  145.     title      := ADR(WindowTitle);
  146.     screen     := NIL; bitMap    := NIL;
  147.     type       := ScreenFlagSet{wbenchScreen};
  148.   END;
  149.   Window := OpenWindow(NuWindow);
  150.   Assert(Window#NIL,ADR("Can't open Window!!!"));
  151.   WBScreen := Window^.wScreen;
  152.   IF WBScreen^.bitMap.depth>2 THEN Terminate(0) END; (* thers sth. strange ! *)
  153.  
  154. (*------  Set Colors:  ------*)
  155.  
  156.   ColTable := WBScreen^.viewPort.colorMap^.colorTable;
  157.   ColTable^[4] := CAST(INTEGER,CAST(BITSET,ColTable^[0] DIV 2)*{0..2,4..6,8..10});
  158.   ColTable^[5] := ColTable^[1];
  159.   ColTable^[6] := ColTable^[2];
  160.   ColTable^[7] := ColTable^[3];
  161.  
  162. (*------  Add Plane to WBScreen:  ------*)
  163.  
  164.   bm := WBScreen^.bitMap;
  165.   WITH bm DO
  166.     INC(rows,8);
  167.     INC(bytesPerRow,2);
  168.     AllocMem(NewPlane1,rows*bytesPerRow+8*bytesPerRow+2,TRUE);
  169.     AllocMem(NewPlane2,rows*bytesPerRow+8*bytesPerRow+2,TRUE);
  170.     Assert((NewPlane1#NIL) AND (NewPlane2#NIL),ADR("Out of memory"));
  171.     planes[0] := NewPlane1;
  172.     planes[1] := NewPlane2;
  173.   END;
  174.   WITH WBScreen^ DO
  175.     l := BltBitMap(ADR(bitMap),0,0,ADR(bm),16,8,width,height,0C0H,3,NIL);
  176.     WITH bitMap DO
  177.       Forbid();
  178.         OldPlane1 := planes[0];
  179.         OldPlane2 := planes[1];
  180.         planes[0] := NewPlane1;
  181.         planes[1] := NewPlane2;
  182.         planes[2] := NewPlane1;
  183.         OldRows   := rows; OldbPR := bytesPerRow;
  184.         INC(rows,8); INC(bytesPerRow,2);
  185.         INC(planes[0],8*bytesPerRow+2);
  186.         INC(planes[1],8*bytesPerRow+2);
  187.       Permit();
  188.  
  189. (*------  Do it:  ------*)
  190.  
  191.       REPEAT
  192.         Forbid();
  193.           depth := 3;
  194.           MakeScreen(WBScreen);
  195.           depth := 2;
  196.         Permit();
  197.         RethinkDisplay();
  198.         Delay(10);
  199.         QuitMessage := GetMsg(MyPort);
  200.       UNTIL QuitMessage#NIL;
  201.     END;
  202.   END;
  203.  
  204. END WBShadow.
  205.